{$i-}
unit FTgr;
interface
uses pictures;


Function SavePictureFtG(var p:picture):Boolean;

Function LoadPictureFtG(var p:picture):integer;

Procedure ReMapPalette(var obr:picture);

Type FtGrHeader=record
	identific:array [1..4] of char;
	ver:	word;
	rows:	Word;
	cols:	Word;
	planes:	Byte;
	compression:Byte;
	Histogram:Longint;	{pointers to a disk file}
	Palette:Longint;
	Data:Longint;
	end;


const SchMask = $7;
      Schless_2d   = 1;
      Schless_3d   = 2;
      Schless_3Dvar= 3;
      Hufmask = $18;
      Huff    =  8;
      HuffVar = $10;
      RemapPal= $20;
      FtGrCompression:Byte=Schless_3D+RemapPal+ HuffVar; {type of compression}


      CBufSize=1024;
      Hu2Sizes:array[0..6] of word = (16,32,64,128,256,512,1024);
      Hu2prefix:array[0..6] of byte= ( 4, 5, 6,  7,  8,  9,  10);

      ZeroValues:array[2..7] of shortint = (3,7,15,31,63,127);
      Aditors:   array[2..7] of shortint = (1,3, 7,15,31, 63);

implementation

const MaxHItems=1024;
Type Ahuf=array[0..MaxHItems] of longint;
     hrec=record
	  size:ShortInt;
	  number:Word;
	  code:longint;
	 end;
     Bhuf=array[0..MaxHItems] of hrec;
     Chuf=array[0..35] of longint;

     pfile=^File;
     BitStream=record
	ptr:^Byte;
	BufStart,BufEnd:Word;
	m:Byte;
	n:Word;


	fileleft:Longint;
	f:Pfile;
	end;

    TSmask3d=set of 0..127;
    TSmask=set of 0..7;
    TSmask1d=set of 0..1;



Function SizeNum(n:word):Word;
begin
 SizeNum:=2;
 if n<=2 then exit;
 SizeNum:=3;
 if n<=4 then exit;
 SizeNum:=5;
 if n<=8 then exit;
 SizeNum:=7;
 if n<=16 then exit;
 SizeNum:=9;
 if n<=32 then exit;
 SizeNum:=11;
 if n<=64 then exit;
 SizeNum:=13;
 if n<=128 then exit;
 SizeNum:=15;
end;


Procedure ReadFromFileBit(var b:bitstream);
var s:longint;
    size:Word;
begin
  word(b.ptr):=b.BufStart;
  if b.FileLeft<=0 then
  	begin
        exit;
        end;

  s:=b.BufEnd-b.BufStart+1;
  if b.FileLeft<s then s:=b.FileLeft;
  BlockRead(b.f^,b.ptr^,b.BufEnd-b.BufStart+1,Size);
  dec(b.FileLeft,Size);
  if (Size=0)or(IOResult<>0) then b.FileLeft:=-1; {error}
end;

Procedure WriteToFileBit(var b:bitstream);
var s2,size:Word;
    pp2:pointer;
begin
  size:=word(b.ptr)-word(b.BufStart)+1;
  if b.m=0 then dec(size);
  word(b.ptr):=b.BufStart;
  if b.FileLeft<0 then
  	begin
        exit;
        end;

  BlockWrite(b.f^,b.ptr^,Size,S2);
  b.m:=$80;
  b.ptr^:=0;
  inc(b.FileLeft,Size);
  if (Size<>S2)or(IOResult<>0) then b.FileLeft:=-1; {error}
end;


Procedure InitBitStream(var b:bitstream;p:pointer;BufSize:Word;f:Pfile;fsiz:longint);
begin
 b.ptr:=p;
 b.ptr^:=0;
 b.m:=$80;
 b.BufEnd:=word(p)+BufSize-1;
 b.BufStart:=word(p);

 b.f:=f;
 b.FileLeft:=fsiz;
 b.n:=0;

 if fsiz>0 then ReadFromFileBit(b);
end;

Function ReadBit(var b:bitstream):Byte;
var a: integer;
begin
ReadBit:=0;
if (b.ptr^ and b.m) <> 0 then ReadBit:=1;

b.m:=b.m shr 1;
if(b.m=0) then
	begin
	inc(b.ptr);
	if word(b.ptr)>b.BufEnd then
		begin
		ReadFromFileBit(b);
		end;
	b.m:=$80;
	end;
end;

Function readnBits(var b:bitstream;n:Word;var param):Word;
var a:word;
    ptrb:^byte;
begin
if n=0 then exit;
ptrb:=addr(param);
a:=0;
ptrb^:=0;
while(n>0) do
	begin
	if a>=8 then
		begin
		inc(ptrb);
		a:=0;
		ptrb^:=0;
		end;
	inc(ptrb^,ReadBit(b) shl a);
	inc(a);
	dec(n);
	end;
end;



Procedure WriteBit(var b:bitstream;x:Boolean);
var a: integer;
begin
if x then b.ptr^:=b.ptr^ or b.m;

b.m:=b.m shr 1;
if(b.m=0) then
	begin
	inc(b.ptr);
	if word(b.ptr)>b.BufEnd then
		begin
		WriteToFileBit(b);
                end;
        inc(b.n);
        b.ptr^:=0;
	b.m:=$80;
	end;
end;


Procedure writenBits(var b:bitstream;n:Word;const param);
var a:byte;
    ptrb:^byte;
begin
if n=0 then exit;
ptrb:=addr(param);

a:=1;
while(n>0) do
	begin
	WriteBit(b,(ptrb^ and a)<>0);
	if a=128 then
		begin
		a:=1;
		inc(ptrb);
		end
		else a:=a shl 1;
	dec(n);
	end;
end;


Procedure WriteNumber(var b:bitstream;x:longint);
var i:word;
    a:longint;
begin
if x=0 then exit;
dec(x);
if x<2 then
	begin
	x:=x shl 1;
	writenBits(b,2,x);
	exit;
	end;
i:=0;
a:=x;
while a>0 do
	begin
	a:=a shr 1;
	inc(i);
	end;

a:=$FFFFFFFF;
writenBits(b,i-1,a);
WriteBit(b,False);
writenBits(b,i-1,x);
end;

Function Prohod(i:longint;li:word):longint;		assembler;
asm
db 66h;	mov	bx,word ptr i
	mov	cx,li
db 66h;	xor	ax,ax
@otoc:
db 66h; shr	bx,1
db 66h;	rcl	ax,1
	loop	@otoc
db 66h; mov	dx,ax
db 66h; shr	dx,16
end;


Procedure WriteHufNum(var b:bitstream;const Huf:bhuf;x:longint;HufIdx:Byte);
var i:word;
    a:longint;
begin
if x=0 then exit;
if x<=Hu2Sizes[HufIdx] then
	begin
	writeNbits(b,Huf[x].size,Huf[x].code);
	exit;
	end;

writeNbits(b,Huf[0].size,Huf[0].code);
dec(x);
i:=0;
a:=x;
while a>0 do
	begin
	a:=a shr 1;
	inc(i);
	end;

a:=$FFFFFFFF;
writenBits(b,i-1-Hu2Prefix[HufIdx],a);
WriteBit(b,False);
writenBits(b,i-1,x);
end;

Function ReadNumber(var b:bitstream):longint;
var i:word;
    n:longint;
begin
i:=0;
readnBits(b,2,i);
i:=prohod(i,2);
if i<2 then		{i=0,1}
	begin
	ReadNumber:=i+1;
	exit;
	end;
dec(i);
if i=2 then
       begin
       i:=2;
       while ReadBit(b)<>0 do inc(i);
       end;

n:=0;
readnBits(b,i,n);
ReadNumber:=(longint(1) shl i) + n + 1;
end;


Function ReadHufNum(var b:bitstream;const bha:Bhuf;const cha:Chuf;HprPos:Byte):longint;
var i:word;
    x,q,n:longint;
begin
i:=0;
q:=0;

repeat
   repeat
   q:=(q shl 1)+readBit(b);
   inc(i);

   until cha[i]<>-1;


x:=bha[cha[i]].code-q;			{!!!!Error!!!!}
until x>=0;

n:=bha[cha[i]-x].number;
if n>0 then
	begin
	ReadHufNum:=n;
	exit;
	end;


i:=HprPos;
while ReadBit(b)<>0 do inc(i);
n:=0;
readnBits(b,i,n);
ReadHufNum:=(longint(1) shl i) + n + 1;
end;


Function SchCount3dfull(var obr,bbr:Picture;var Smask3:Tsmask3d;var Smask2:Tsmask;
			var koutecku2:longint):Longint;
var x,y:Word;
    mask,ii,i:byte;
    a:array[0..255] of longint;
    koutecku3f:longint;
    p1,p2,p3,p4:^Byte;
begin
if ((obr.Planes<>1)or(not(Obr.Valid))) then exit;

fillchar(a,sizeof(a),0);
for y:=0 to Obr.y-2 do		{hlavni radkova smycka}
	begin
	p1:=pointer(Obr.data^[y]);
	p2:=pointer(Obr.data^[y+1]);
	i:=32*Pixel(obr,0,y)+128*Pixel(obr,0,y+1);	{-1 radek 1. 1/2}

	p3:=p1;				{for Invalid Bbr}
	p4:=p2;
	if Bbr.Data<>nil then
	  begin
	  p3:=pointer(Bbr.data^[y]);
	  p4:=pointer(Bbr.data^[y+1]);
	  i:=i or 2*Pixel(bbr,0,y)+  8*Pixel(bbr,0,y+1); {-1 radek 2. 1/2}
	  end;


	mask:=64;
	for x:=0 to Obr.x-2 do
		begin
		i:= ((i shr 1)and $55);
		if (p1^ and mask)<>0 then i:=i or 32;
		if (p2^ and mask)<>0 then i:=i or 128;
		if (p3^ and mask)<>0 then i:=i or 2;
		if (p4^ and mask)<>0 then i:=i or 8;


		mask:=mask shr 1;
		if mask=0 then
			begin
			mask:=128;
			inc(p1);
			inc(p2);
			inc(p3);
			inc(p4);
			end;
		inc(a[i]);
		end;
	end;

Smask3:=[];		{vypocet 3D masky}
koutecku3f:=0;
for i:=0 to 127 do
	if a[i+128]>a[i] then begin
			    Smask3:=Smask3 + [i];
			    inc(koutecku3f,a[i]);
			    end
		       else inc(koutecku3f,a[i+128]);

for i:=0 to 127 do a[i]:=a[2*i]+a[2*i+1];	{postupne redukce}
for i:=0 to 63  do a[i]:=a[2*i]+a[2*i+1];
for i:=0 to 31  do a[i]:=a[2*i]+a[2*i+1];
for i:=0 to 15  do a[i]:=a[2*i]+a[2*i+1];

Smask2:=[];		{vypocet 2D masky}
koutecku2:=0;
for i:=0 to 7 do
	begin
	if a[i+8]>a[i] then begin
			    Smask2:=Smask2 + [i];
			    inc(koutecku2,a[i]);
			    end
		       else inc(koutecku2,a[i+8]);
	end;

SchCount3dfull:=koutecku3f;
end;



Procedure SchComp(var obr:Picture;Smask:Tsmask);
var x,y:Word;
    Rmask,i,ii:byte;
    p1,p2:^Byte;

begin
if ((obr.Planes<>1)or(not(Obr.Valid))) then exit;

for y:=Obr.y-2 downto 0 do		{hlavni radkova smycka}
	begin
        p1:=pointer(Obr.data^[y]);
        p2:=pointer(Obr.data^[y+1]);
        inc(p1,(Obr.x-2) shr 3);
        inc(p2,(Obr.x-2) shr 3);
        Rmask:=128 shr ((Obr.x-2) and 7);

        i:=Pixel(obr,Obr.x-1,y)+4*Pixel(obr,Obr.x-1,y+1); {obr.x-1 sloupec}
	for x:=Obr.x-2 downto 0 do
		begin
                i:= ((i shl 1)and $A);
                if (p1^ and rmask)<>0 then i:=i or 1;
                if (p2^ and rmask)<>0 then i:=i or 4;
                rmask:=rmask shl 1;
                if rmask=0 then
                	begin
                        rmask:=1;
                        dec(p1);
                        dec(p2);
                        end;

                if ((i and 7) in Smask)
			then
			begin
			if (i>=8) then SetPixel(obr,x+1,y+1,0)  {px=1}
                	          else SetPixel(obr,x+1,y+1,1); {px=0}
                        end
{                        else begin
			 if (i>=8) then SetPixel(obr,x+1,y+1,1)	px already 1
                	          else SetPixel(obr,x+1,y+1,0); px already 0
                         end;}
		end;
	end;
end;


Procedure SchComp3d(var obr,bbr:Picture;Smask:Tsmask3d);
var x,y:Word;
    Rmask,i,ii:byte;
    p1,p2,p3,p4:^Byte;
begin
if ((obr.Planes<>1)or(not(Obr.Valid))) then exit;

for y:=Obr.y-2 downto 0 do		{hlavni radkova smycka}
	begin
	p1:=pointer(Obr.data^[y]);
	p2:=pointer(Obr.data^[y+1]);
	p3:=pointer(Bbr.data^[y]);
	p4:=pointer(Bbr.data^[y+1]);
	inc(p1,(Obr.x-2) shr 3);
	inc(p2,(Obr.x-2) shr 3);
	inc(p3,(Obr.x-2) shr 3);
	inc(p4,(Obr.x-2) shr 3);

	Rmask:=128 shr ((Obr.x-2) and 7);

	
	i:=    Pixel(Bbr,Obr.x-1,y)+ 4*Pixel(Bbr,Obr.x-1,y+1)+
	   +16*Pixel(Obr,Obr.x-1,y)+64*Pixel(Obr,Obr.x-1,y+1); {obr.x-1 sloupec}

	for x:=Obr.x-2 downto 0 do
		begin
		i:= ((i shl 1)and $AA);
		if (p1^ and rmask)<>0 then i:=i or 16;
		if (p2^ and rmask)<>0 then i:=i or 64;
		if (p3^ and rmask)<>0 then i:=i or 1;
		if (p4^ and rmask)<>0 then i:=i or 4;
		rmask:=rmask shl 1;
                if rmask=0 then
                	begin
			rmask:=1;
                        dec(p1);
                        dec(p2);
			dec(p3);
			dec(p4);
			end;

		if ((i and 127) in Smask)
			then
			begin
			if (i>=128) then SetPixel(obr,x+1,y+1,0)  {px=1}
				    else SetPixel(obr,x+1,y+1,1); {px=0}
                        end
{                        else begin
			 if (i>=8) then SetPixel(obr,x+1,y+1,1)	px already 1
                	          else SetPixel(obr,x+1,y+1,0); px already 0
                         end;}
		end;
	end;
end;



Procedure DeSchless(var obr:Picture; Smask:Tsmask);
var x,y:Word;
    ii,i,Rmask:byte;
    p1,p2:^byte;
begin
if ((obr.Planes<>1)or(not(Obr.Valid))) then exit;

for y:=0 to Obr.y-2 do		{hlavni radkova smycka}
	begin
        p1:=pointer(Obr.data^[y]);
        p2:=pointer(Obr.data^[y+1]);
        Rmask:=64;

        i:=2*Pixel(obr,0,y)+8*Pixel(obr,0,y+1); {-1 radek}
	for x:=0 to Obr.x-2 do
		begin
                i:= ((i shr 1)and 5);
		if (p1^ and Rmask)<>0 then i:=i or 2;
                if (p2^ and Rmask)<>0 then i:=i or 8;
		Rmask:=Rmask shr 1;
                if Rmask=0 then
			begin
			Rmask:=128;
                        inc(p1);
                        inc(p2);
                        end;

                if ((i and 7) in Smask) then
                        begin
			if (i>=8) then begin
			               SetPixel(obr,x+1,y+1,0);
                                       i:=i and 7;
	                               end
        			  else begin
				       SetPixel(obr,x+1,y+1,1);
                                       i:=i or 8;
                                       end;
                        end;
{			else	- already set - no change}
		end;
	end;
end;


Procedure DeSchless3d(var obr,bbr:Picture; Smask:Tsmask3d);
var x,y:Word;
    ii,i,Rmask:byte;
    p1,p2,p3,p4:^byte;
begin
if ((obr.Planes<>1)or(not(Obr.Valid))) then exit;

for y:=0 to Obr.y-2 do		{hlavni radkova smycka}
	begin
	p1:=pointer(Obr.data^[y]);
	p2:=pointer(Obr.data^[y+1]);
	p3:=p1;				{for Invalid Bbr}
	p4:=p2;

	i:=32*Pixel(obr,0,y)+128*Pixel(obr,0,y+1);
	if Bbr.Data<>nil then
	  begin
	  p3:=pointer(Bbr.data^[y]);
	  p4:=pointer(Bbr.data^[y+1]);
	  i:=i + 2*Pixel(bbr,0,y)+  8*Pixel(bbr,0,y+1); {-1 radek}
	  end; (* *)


	Rmask:=64;

	for x:=0 to Obr.x-2 do
		begin
		i:= ((i shr 1)and $55);
		if (p1^ and Rmask)<>0 then i:=i or 32;
		if (p2^ and Rmask)<>0 then i:=i or 128;
		if (p3^ and Rmask)<>0 then i:=i or 2;
		if (p4^ and Rmask)<>0 then i:=i or 8;
		Rmask:=Rmask shr 1;
                if Rmask=0 then
			begin
			Rmask:=128;
			inc(p1);
			inc(p2);
			inc(p3);
			inc(p4);
			end;

		if ((i and 127) in Smask) then
			begin
			if (i>=128) then begin
					 SetPixel(obr,x+1,y+1,0);
					 i:=i and 127;
					 end
				    else begin
					 SetPixel(obr,x+1,y+1,1);
					 i:=i or 128;
					 end;
			end;
{			else	- already set - no change}
		end;
	end;
end;




Function Schless1d(var obr:picture;x,y,kx,ky:word;var S1:TSmask1d):Word;
var M:byte;
    i,Max:Word;
    a:array[0..3] of word;
    koutecku:Word;
begin
 if not(obr.Valid) or (obr.planes<>1) then exit;

 fillchar(a,sizeof(a),0);

 if Kx=0 then Max:=obr.y-2;
 if Ky=0 then Max:=obr.x-2;

 for i:=0 to Max do
	begin
	M:=  pixel(obr,x+(kx and i),y+(ky and i))+
	   2*pixel(obr,x+(kx and (i+1)),y+(ky and (i+1)));
	inc(a[M]);
	end;

 S1:=[];
 koutecku:=0;
 for i:=0 to 1 do
	if a[i+2]>a[i] then
		begin
		S1:=S1 + [i];
		inc(koutecku,a[i]);
		end
		else inc(koutecku,a[i+2]);

 for i:=Max downto 0 do
	begin
	M:=pixel(obr,x+(kx and i),y+(ky and i));

	if (M in S1)xor(pixel(obr,x+(kx and (i+1)),y+(ky and (i+1)))=1)
		then SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),1)
		else SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),0);
	end;

Schless1d:=koutecku;
end;

Function DeSchless1d(var obr:picture;x,y,kx,ky:word;S1:TSmask1d):Word;
var M:Byte;
    Max:word;
    i:Word;
begin
 if Kx=0 then Max:=obr.y-2;
 if Ky=0 then Max:=obr.x-2;

 for i:=0 to Max do
	begin
	M:=pixel(obr,x+(kx and i),y+(ky and i));

	if (M in S1)xor(pixel(obr,x+(kx and (i+1)),y+(ky and (i+1)))=1)
		then SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),1)
		else SetPixel(obr,x+(kx and (i+1)),y+(ky and (i+1)),0);
	end;
end;


Procedure Huffman(const aAHuf;var b:Bhuf;Hitems:Word);
type fArray=array[0..MaxHItems] of word;
     PfArray=^fArray;
     Hufstruct=record
	value:longint;
	NumDat:word;
	data:PfArray;
	end;
     HufArray=record
	number:Word;
	a:array[0..MaxHItems] of HufStruct;
	end;


var a:Ahuf absolute aAhuf;
    HufRec:^HufArray;
    Hr:HufStruct;
    i,j,k:Word;

    Procedure InsSort(H:HufStruct);
    var i:Word;
    begin
    i:=HufRec^.number;
    if i>0 then
      while (HufRec^.a[i-1].Value<H.Value) do
	begin
	HufRec^.a[i]:=HufRec^.a[i-1];
	dec(i);
	if i=0 then break;
	end;
    HufRec^.a[i]:=H;
    inc(HufRec^.number);
    end;

begin
new(Hufrec);
fillchar(HufRec^,sizeof(Hufrec^),0);

for i:=0 to HItems do      	{zarazovani novych polozek}
  if a[i]<>0 then
	begin
	Hr.value:=a[i];
	Hr.NumDat:=i;
	Hr.Data:=nil;
	InsSort(Hr);
	end;
for i:=0 to HufRec^.Number-1 do {alokace pameti}
	begin
	getmem(HufRec^.a[i].data,Sizeof(Word));
	HufRec^.a[i].data^[0]:=HufRec^.a[i].NumDat;
	HufRec^.a[i].NumDat:=1;
	end;

fillchar(b,sizeof(b),0);

while HufRec^.Number>=2 do	{Huffmanova redukce}
	begin
	k:=HufRec^.Number-2;

	Hr.value:= HufRec^.a[k].Value+HufRec^.a[k+1].Value;
	Hr.numdat:=HufRec^.a[k].NumDat+HufRec^.a[k+1].NumDat;
	getmem(Hr.data,Hr.numdat*Sizeof(Word));
	for i:=0 to HufRec^.a[k].NumDat-1 do
		begin
		Hr.data^[i]:=HufRec^.a[k].Data^[i];
		inc(b[Hr.data^[i]].size);
		end;
	j:=HufRec^.a[k].NumDat;
	for i:=0 to HufRec^.a[k+1].NumDat-1 do
		begin
		Hr.data^[i+j]:=HufRec^.a[k+1].Data^[i];
		inc(b[Hr.data^[i+j]].size);
		end;


	dec(HufRec^.Number,2);
	freemem(HufRec^.a[k].data,HufRec^.a[k].NumDat*Sizeof(Word));
	HufRec^.a[k].NumDat:=0;
	HufRec^.a[k].Data:=nil;
	freemem(HufRec^.a[k+1].data,HufRec^.a[k+1].NumDat*Sizeof(Word));
	HufRec^.a[k+1].NumDat:=0;
	HufRec^.a[k+1].Data:=nil;

	InsSort(Hr);
	end;


for i:=0 to HufRec^.Number-1 do
	begin
	freemem(HufRec^.a[i].data,HufRec^.a[i].NumDat*Sizeof(Word));
	HufRec^.a[i].NumDat:=0;
	HufRec^.a[i].Data:=nil;
	end;
for i:=0 to HItems do b[i].Number:=i;
dispose(HUfrec);
end;

Procedure SortSize(var b:Bhuf;var c:chuf;Hitems:Word);
var x,y:integer;
    huhu:hrec;
begin
 for x:=0 to Hitems do	{sort}
	for y:=0 to Hitems-x-1 do
		if b[y].size>b[y+1].size then
			begin
			huhu:=b[y+1];
			b[y+1]:=b[y];
			b[y]:=huhu;
			end;

 fillchar(c,sizeof(c),$FF);
 for x:=0 to Hitems do c[b[x].size]:=x; {positions}
end;


Procedure SortNum(var b:Bhuf;Hitems:Word);
var x,y:integer;
    huhu:hrec;
begin
 for x:=0 to Hitems-1 do	{sort}
	while b[x].number<>x do
		begin
		y:=b[x].number;

		huhu:=b[x];
		b[x]:=b[y];
		b[y]:=huhu;
		end;
end;

Procedure HufCount(var b:Bhuf;const c:Chuf;HItems:Word);
var x:word;
    y:longint;
begin
 y:=0;

 if c[0]=-1 then x:=0
	    else x:=c[0]+1;

 b[x].code:=y;
 inc(x);
 while x<=Hitems do
		begin
		inc(y);
		if b[x].size>b[x-1].size then
			y:=y shl (b[x].size-b[x-1].size);
		b[x].code:=y;
		inc(x);
		end;

end;

Function PacKSizes(var b:Bhuf;MaxItems:Word):Byte;
var i:integer;
    min,max,t,lastS:shortint;

begin
min:=0;max:=0;
lastS:=2;
for i:=1 to MaxItems do
	begin
	if b[i].size=0 then b[i].size:=127
		       else
		       begin
		       t:=b[i].size;
		       b[i].size:=b[i].size-lastS;
		       if b[i].size>Max then Max:=b[i].size;
		       if b[i].size<Min then Min:=b[i].size;
		       lastS:=t;
		       end;
	end;

t:=7;
if (Max<=31)and(Min>=-31) then t:=6;
if (Max<=15)and(Min>=-15) then t:=5;
if (Max<=7)and(Min>=-7) then t:=4;
if (Max<=3)and(Min>=-3) then t:=3;
if (Max<=1)and(Min>=-1) then t:=2;

for i:=1 to MaxItems do
	if b[i].size=127 then b[i].size:=ZeroValues[t]
			 else inc(b[i].size,Aditors[t]);

PacKSizes:=t;
end;


Function UnPacKSizes(var b:Bhuf;MaxItems:Word;t:shortint):Byte;
var i:integer;
    lastS:shortint;

begin
lastS:=2;
for i:=1 to MaxItems do
	begin
	if b[i].size=ZeroValues[t] then b[i].size:=0
		       else
		       begin
		       dec(b[i].size,Aditors[t]);
		       b[i].size:=LastS+b[i].size;
		       LastS:=b[i].size;
		       end;
	end;

end;



Function SavePictureFtG(var p:picture):Boolean;
var f:file;
    Ldblk:Word;
    x,y:integer;
    lastX:longint;
    i:Word;
    Header:FtGrHeader;
    bit:BitStream;
    planeX,planeXold:picture;
    koutecku,koutecku3d:longint;
    Smask3d,Smask3dJ:TSmask3d;
    Smask:TSmask;
    Smask1d:TSmask1d;
    CompBuffer:pointer;
    ishuffman:Boolean;
    Aha:Ahuf;
    Bha:Bhuf;
    Cha:Chuf;
    pb:^Byte;
    rotm:Byte;

    Hufn:Byte;
    HufZero:Longint;
    HufMax:Longint;
    MaxHuTbSize:byte;

label KONEC,NewExit;
begin
 planeX.init;
 planeXold.init;
 CompBuffer:=nil;
 SavePictureFTG:=False;
 if p.data=nil then exit;

 fillchar(Header,Sizeof(Header),#0);
 Header.Rows:=p.x;
 Header.Cols:=p.y;
 Header.Ver:=1;
 Header.Planes:=p.planes;
 Header.identific:='F&Tg';
 Header.Data:=Sizeof(Header);
 Header.Compression:=FtGrCompression;
 assign(f,p.filename^);
 filemode:=2;
 rewrite(f,1);
 if IOresult<>0 then exit;
 Blockwrite(f,Header,sizeof(Header),Ldblk);


 ldblk:=(p.planes*p.x+7) div 8;

 if Header.Compression<>0 then
    begin
    if (p.x+p.y)<8 then Header.Compression:=0; {too small picture}
    end;

 if Header.Compression<>0 then
    begin
    if (Header.Compression and ReMapPal)<>0 then ReMapPalette(p);

    ldblk:=(p.x+7) div 8;
    GetMem(CompBuffer,CBufSize);
    initBitStream(bit,CompBuffer,CBufSize,@f,0);


{    for lastX:=65534 to 100000 do writenumber(bit,lastX);
{    for x:=1 to 2000 do writenumber(bit,x);	{---test---}

    for i:=p.planes downto 1 do
	begin
	PeelPlane(p,planeX,i);

	koutecku3d:=MaxLongInt;
	lastX:=MaxLongInt;;
	if (i=p.planes) or (Header.Compression and SchMask < Schless_3d) then
		LastX:=SchCount3dfull(planeX,planeXold,Smask3d,Smask,koutecku)
	    else for x:= i+1 to p.planes do
		begin
		PeelPlane(p,planeXold,x);
		LastX:=SchCount3dfull(planeX,planeXold,Smask3dJ,Smask,koutecku);
		if LastX+2<koutecku3d then
			begin
			koutecku3d:=LastX+1;
			Smask3D:=Smask3dJ;
			y:=x;
			end;
		if (Header.Compression and SchMask < Schless_3dVar) then break;
		end;
	inc(koutecku);

	if koutecku3d<=koutecku then	{je vhodne provadet koutecky 3D?}
		begin
		if (longint(planeX.x-1)*(planeX.y-1)/koutecku3d > 2.8) and
			((koutecku-koutecku3d)div 4 > Sizeof(Smask3d)-Sizeof(Smask))
			then begin
			     if x<>y then PeelPlane(p,planeXold,y);
			     koutecku:=koutecku3d
			     end
			else koutecku3d:=MaxLongInt;
		end;


	if (longint(planeX.x-1)*(planeX.y-1)/koutecku > 2.5)
	    then begin
		 if koutecku3d=MaxLongInt then
			begin
			x:=1;
			writenBits(bit,2,x);
			writenBits(bit,8,Smask);
			SchComp(planeX,Smask);
			end
			else begin
			     if y>i+1 then begin
					   x:=3;
					   writenBits(bit,2,x);
					   x:=y-i-1;
					   writenBits(bit,3,x);
					   end
				      else begin
					   x:=2;
					   writenBits(bit,2,x);
					   end;
			     writenBits(bit,8*sizeof(Smask3d),Smask3d);
			     SchComp3d(planeX,planeXold,Smask3d);
			     end;

		 Schless1d(planeX,0,0,$FFFF,0,Smask1d); {0 ty radek}
		 writenBits(bit,2,Smask1d);
		 Schless1d(planeX,0,0,0,$FFFF,Smask1d);	{0 ty sloupec}
		 writenBits(bit,2,Smask1d);

{-------Huffmanova komprese--LZW------------}
		 isHuffman:=False;
		 if (Header.Compression and HufMask)<>0 then
			begin
			fillchar(aha,sizeof(aha),0);
			lastX:=-1;
			for y:=0 to planeX.y-1 do
			    begin
			    Rotm:=128;
			    pb:=pointer(planeX.data^[y]);

			    for x:=0 to planeX.x-1 do
				begin
				if pb^ and rotm <> 0 then
					begin
					lastX:=longint(x)-LastX;
					if lastX>MaxHItems then lastX:=0;
					inc(aha[lastX]);
					lastX:=x;
					end;

				Rotm:=Rotm shr 1;
				if Rotm=0 then
					begin
					Rotm:=128;
					inc(pb);
					end;
				end;
			    lastX:=lastX - planeX.x;
			    end;
			 if lastX<0 then
				begin
				lastX:= -LastX;
				if lastX>MaxHItems then lastX:=0;
				inc(aha[lastX]);
				end;


			HufZero:=aha[0];
			HufMax:=0;
			y:=0;
			for HufN:=0 to 6 do
			  begin
			  aha[0]:=HufZero;
			  for x:=Hu2Sizes[HufN]+1 to MaxHitems do inc(aha[0],aha[x]);
			  huffman(aha,bha,Hu2Sizes[HufN]);

			  lastX:=aha[0]*(Hu2Prefix[HufN]-bha[0].size);

			  MaxHuTbSize:=0;
			  for x:=1 to Hu2Sizes[HufN] do
				begin
				lastX:=lastX+ aha[x]*(longint(sizenum(x))-bha[x].size);
				end;			  {zmena delky dat}

			  MaxHuTbSize:=PackSizes(bha,Hu2Sizes[HufN]);
			  UnPackSizes(bha,Hu2Sizes[HufN],MaxHuTbSize);

			  lastX:=LastX-Hu2Sizes[HufN]*MaxHuTbSize;  {delka tabulky}

			  if LastX<HufMax+16 then break;   {-- funkce uz klesa}
			  if lastX>HufMax then
				begin
				HufMax:=LastX;
				y:=HufN;
				end;
			  end;

			HufN:=y;
			aha[0]:=HufZero;
			for x:=Hu2Sizes[HufN]+1 to MaxHitems do inc(aha[0],aha[x]);
			huffman(aha,bha,Hu2Sizes[HufN]);


			sortSize(bha,cha,Hu2Sizes[HufN]);
			hufcount(bha,cha,Hu2Sizes[HufN]);
			sortNum(bha,Hu2Sizes[HufN]);

			isHuffman:=HUfMax>4;
			if isHuffman then
				begin
				MaxHuTbSize:=PackSizes(bha,Hu2Sizes[HufN]);
				if MaxHuTbSize>5 then isHuffman:=False;  {vice bitu zatim neumim}
				end;
			end;

		writeBit(bit,isHuffman);
		if isHuffman then
			begin

			WriteNBits(bit,3,HufN);

			dec(MaxHuTbSize,2);	{2..5->0..3}
			WriteNBits(bit,2,MaxHuTbSize);
			inc(MaxHuTbSize,2);	{0..3->2..5}

			WriteNumber(bit,bha[0].size+1);
			for x:=1 to Hu2Sizes[HufN] do
				begin
				writeNbits(bit,MaxHuTbSize,bha[x].Size);
				end;
			UnPackSizes(bha,Hu2Sizes[HufN],MaxHuTbSize);
			for x:=0 to Hu2Sizes[HufN] do
				begin
				bha[x].code:=prohod(bha[x].code,bha[x].size);
				end;
			end;
{-------konec Huffmanovy komprese--LZW------------}

		 lastX:=-1;
		 for y:=0 to planeX.y-1 do
		    begin
		    Rotm:=128;
		    pb:=pointer(planeX.data^[y]);

		    for x:=0 to planeX.x-1 do
			begin
			if pb^ and rotm <> 0 then
				begin
				if isHuffman
					then writeHufNum(bit,bha,longint(x)-LastX,HufN)
					else writeNumber(bit,longint(x)-LastX);

				lastX:=x;
				end;
			Rotm:=Rotm shr 1;
			if Rotm=0 then
				  begin
				  Rotm:=128;
				  inc(pb);
				  end;
			end;
		    lastX:=lastX - planeX.x;
		    end;
		 if lastX<-1 then
			begin
			if isHuffman then writeHufNum(bit,bha,0-LastX,HufN)
				     else writeNumber(bit,0-LastX);
			end;
		 end
	    else begin
		 y:=0;
		 writenBits(bit,2,y);
		 for y:=0 to planeX.y-1 do
		    begin
		    writenBits(bit,p.x,planeX.data^[y]^);
		    end;
		 end;
	end;

    WriteToFileBit(bit);
    end;

 if Header.Compression=0 then
    begin
    for y:=0 to p.y-1 do		{no compression}
 	begin
	BlockWrite(f,p.data^[y]^,LdBlk);
	AlineProc(y,p);
	end;
    end;


  if p.palette<>nil then		{ulozeni palety}
	begin
	header.palette:=filepos(f);
	blockwrite(f,p.palette^,3*p.palette^.colors+2);
	seek(f,0);
	Blockwrite(f,Header,sizeof(Header),Ldblk);
	end;



KONEC:
 close(f);
 if IOResult<>0 then Goto NewExit;
 SavePictureFtG:=True;
NewExit:
 if CompBuffer<>nil then Freemem(CompBuffer,CBufSize);
 planeX.done;
 planeXold.done;
end;


Function LoadPictureFtG(var p:picture):integer;
var f:file;
    Ldblk:Word;
    x,y:integer;
    NewX:Longint;
    i,num:byte;
    Header:FtGrHeader;
    CompBuffer:Pointer;
    bit:BitStream;
    planeX,planeXold:picture;
    Smask3d:TSmask3d;
    Smask:TSmask;
    Smask1dx,Smask1dy:TSmask1d;
    pictdata:pointer;

    bha:Bhuf;
    cha:Chuf;
    isHuff:byte;

    Hufn,HufTblSize:Byte;

label KONEC;
begin
 LoadPictureFtG:=0;
 p.Erase;
 planeX.init;
 planeXold.init;
 CompBuffer:=nil;
 assign(f,p.filename^);
 reset(f,1);
 LoadPictureFtG:=InOutRes;
 if(IOresult<>0) then exit;
 BlockRead(f,Header,sizeof(Header),Ldblk);
 if Header.Identific<> 'F&Tg' then goto KONEC;
 p.Create(Header.Rows,Header.Cols,Header.planes);
 Seek(f,Header.Data);

 ldblk:=(p.planes*p.x+7) div 8;

 if Header.Compression=0 then	{no compression}
     begin
     for y:=0 to p.y-1 do
		begin
		Blockread(f,p.data^[y]^,LdBlk);
	        AlineProc(y,p);
                end;
     end;

 if Header.Compression<>0 then	{Schlesinger compression}
     begin
     ldblk:=(p.x+7) div 8;

     GetMem(CompBuffer,CBufSize);
     initBitStream(bit,CompBuffer,CBufSize,@f, maxlongint);

{    for NewX:=65534 to 100000 do
	begin
	ladix:=readNumber(bit);
	if ladix<>newX then
		asm int 3; end;
	end;				{---test---}


     for i:=p.planes downto 1 do
	begin
	if i<p.planes then
		begin
		pictData:=planeXOld.data;
		planeXold.planes:=planeX.planes;
		planeXold.data:=planeX.data;
		planeXold.x:=planeX.x;
		planeXold.y:=planeX.y;
		planeX.data:=PictData;
		end;
	planeX.Create(Header.Rows,Header.Cols,1);

	num:=0;
	readnBits(bit,2,num);
	if num>=1 then
		begin
		if num=3 then		{jina rovina}
			begin
			y:=0;
			ReadNBits(bit,3,y);
			y:=i+y+1;
			peelPlane(p,PlaneXold,y);
			end;

		if num=1 then readnBits(bit,8,Smask)
			 else readnBits(bit,8*sizeof(Smask3d),Smask3d);

		readnBits(bit,2,Smask1dx);
		readnBits(bit,2,Smask1dy);

		isHuff:=readBit(bit);
		if isHuff=1 then
			begin
			HufN:=0;
			HufTblSize:=0;
			ReadNBits(bit,3,HufN);
			ReadNBits(bit,2,HufTblSize);
			inc(HufTblSize,2);	{0..3->2..5}

			fillchar(bha,sizeof(bha),0);

			bha[0].Size:=ReadNumber(bit)-1;
			for x:=1 to Hu2Sizes[HufN] do
				begin
				ReadNBits(bit,HufTblSize,bha[x].Size);
				bha[x].Number:=x;
				end;
			UnPackSizes(bha,Hu2Sizes[HufN],HufTblSize);

			sortSize(bha,cha,Hu2Sizes[HufN]);
			hufcount(bha,cha,Hu2Sizes[HufN]);

			inc(HufN,Hu2Prefix[0]); {delka prefixu v bitech}
			end;

		NewX:=-1;
		y:=0;
		while y<=planeX.y-1 do
		   begin
		   if isHuff=1 then inc(NewX,ReadHufNum(bit,bha,cha,HufN))
			       else inc(NewX,ReadNumber(bit));

		   if NewX>=planeX.x-1 then
		     begin

		     while NewX>planeX.x-1 do	{konec radky}
			  begin
			  inc(y);
			  dec(NewX,planeX.x);
			  end;

		     if (NewX=planeX.x-1)and(y=planeX.y-1) then
				begin
				SetPixel(planeX,NewX,y,1);	{last pixel}
				break;
				end;
		     end;
		   if y<=planeX.y-1 then SetPixel(planeX,NewX,y,1);
		   end;



		if (NewX<>0)and(NewX<>planeX.X-1) then
			begin
			asm int 3; end;
			goto Konec; {Load ERROR!}
			end;

		DeSchless1d(planeX,0,0,$FFFF,0,Smask1dx);
		DeSchless1d(planeX,0,0,0,$FFFF,Smask1dy);
		if num=1 then DeSchless(planeX,Smask)
			 else DeSchless3d(planeX,planeXold,Smask3d);
		end
	   else begin
		for y:=0 to planeX.y-1 do
		    begin
		    readnBits(bit,p.x,planeX.data^[y]^);
		    end;
		 end;
	JoinPlane(planeX,p,i);
	end;
   end;

   if header.palette<>0 then		{nacteni palety}
	begin
	seek(f,header.palette);
	blockread(f,x,2);
	if x<>0 then
		begin
		createpalette(p.palette,p.planes);
		if x>p.palette^.colors then x:=p.palette^.colors;
		blockread(f,p.palette^.pal,3*x);
		end;
	end;



KONEC:
 close(f);
 if CompBuffer<>nil then Freemem(CompBuffer,CBufSize);
 if IOResult<>0 then p.Erase;
 planeX.done;
 planeXold.done;
end;



{----------------Procedury pro premapovani palety-------------------}
Procedure OhodnotInterval(mmm:byte;min,max:integer;var pom:picture;var qoc:array of byte;var results:array of longint);
var i,j,k:integer;
    q:longint;
    b:Byte;
label Pokracuj;
begin
j:=(max+min) div 2;
k:=j+1;

Pokracuj:
for i:=min to j-1 do		{sort}
	begin
	if results[i]<results[j] then
		begin
		q:=results[j];
		results[j]:=results[i];
		results[i]:=q;

		b:=qoc[j];
		qoc[j]:=qoc[i];
		qoc[i]:=b;
		end
	end;

for i:=max downto k+1 do		{sort}
	begin
	if results[i]<results[k] then
		begin
		q:=results[k];
		results[k]:=results[i];
		results[i]:=q;

		b:=qoc[k];
		qoc[k]:=qoc[i];
		qoc[i]:=b;
		end
	end;

if Results[j]+results[k]<0 then
	begin
	q:=results[k];
	results[k]:=-results[j];
	results[j]:=-q;

	b:=qoc[k];
	qoc[k]:=qoc[j];
	qoc[j]:=b;

	for i:=0 to pom.X do
		begin
		if (i=j)or(i=k) then continue;

		if (i and mmm)=(j and mmm)
			then begin
			     inc(Results[i],2*Pixel(pom,qoc[i],qoc[j]));
			     dec(Results[i],2*Pixel(pom,qoc[i],qoc[k]));
			     end
			else begin
			     dec(Results[i],2*Pixel(pom,qoc[i],qoc[j]));
			     inc(Results[i],2*Pixel(pom,qoc[i],qoc[k]));
			     end;

		end;

	goto pokracuj;
	end;
end;


Procedure NewResults(mmm:word;var pom:picture;var qoc:array of byte;var results:array of longint);
var i,j:integer;
begin
fillchar(results,sizeof(results),0);
for i:=0 to pom.x-1 do
  for j:=0 to pom.x-1 do
	begin
	if i=j then continue;
	if (i and mmm)=(j and mmm) then inc(Results[i],Pixel(pom,qoc[i],qoc[j]))
				   else dec(Results[i],Pixel(pom,qoc[i],qoc[j]));
	end;

end;

Procedure ReMapPalette(var obr:picture);
var i,j,k:integer;
    ukw,ukw2:^word;
    ukl,ukl2:^word;
    q:longint;

    pom:picture;
    qoc,qoc2:array[0..255] of byte;
    results:array[0..255] of longint;
    OldPal,NewPal:Ppalette;
begin
if (not(obr.valid) or (obr.palette=nil))or(obr.planes>8) then exit;
getmem(ukw,2*obr.x);
getmem(ukl,2*obr.x);
pom.Init;
i:=1 shl obr.planes;
pom.Create(i,i,16);

for i:=0 to obr.y-1 do
	begin
	ukw2:=ukw;
	ukl2:=ukl;
	formr(obr,i,ukw);
	if i=0 then fillchar(ukl^,2*Obr.x,$FF)
	       else formr(obr,i-1,ukl);

	for j:=0 to obr.x-2 do
		begin
		q:=ukw2^;
		inc(ukw2);
		setpixel(pom,q,ukw2^,pixel(pom,q,ukw2^)+1);
		setpixel(pom,q,ukl2^,pixel(pom,q,ukl2^)+1);
		inc(ukl2);
		setpixel(pom,q,ukl2^,pixel(pom,q,ukl2^)+1);
		end;
	end;
freemem(ukw,2*obr.x);
freemem(ukl,2*obr.x);


for i:=0 to pom.x-1 do		{trojuhelnikova matice - vyrovnej nad a pod diagonalou}
  begin
  for j:=i+1 to pom.x-1 do
	begin
	q:=pixel(pom,i,j)+pixel(pom,j,i);
	SetPixel(pom,j,i,q);
	SetPixel(pom,i,j,q);
	end;
  end;

SortPal(obr.palette,qoc);

q:=pom.x;
for j:=obr.planes downto 1 do
	begin
	k:=1 shl (j-1);
	NewResults(k,pom,qoc,results);

	i:=0;
	while (i+q)-1<pom.x do
		begin
		OhodnotInterval(k,i,(i+q)-1,pom,qoc,results);
		inc(i,q)
		end;

	q:=q div 2;
	end;

pom.Done;

for i:=0 to Obr.Palette^.Colors-1 do qoc2[qoc[i]]:=i;	{inverzni funkce qoc}
Operation1(obr,ReTabB,addr(qoc2));

OldPal:=Obr.Palette;			{premapovani palety}
Obr.Palette:=nil;
CreatePalette(Obr.palette,Obr.planes);
for i:=0 to OldPal^.Colors-1 do
	begin
	Obr.Palette^.pal[i]:=OldPal^.pal[qoc[i]];
	end;
NewPal:=Obr.Palette;
Obr.Palette:=OldPal;
ErasePalette(Obr.palette);
Obr.Palette:=NewPal;
end;


begin
end.

algoritmy: 2D Schlesinger
	   Exponencialni kod
	   1D Sch okraje
	   3D Schlesinger pro sedotonove obrazky
	   LZW casti kodu

zatim neimplementovano:
	   plovouci n
	   LZW^2
	   LZW^2 specialni kruhovy kod (bomba!)
	   		
